perm filename EMACLS.1[MAC,LSP] blob
sn#570676 filedate 1981-03-08 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00019 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MacLisp portion of the E/MacLisp Interface.
C00007 00003 From E to MacLisp
C00011 00004 (entry em:mailtype subr)
C00016 00005 (entry em:wait-mail subr)
C00017 00006 (entry em:mail-sfa subr)
C00018 00007 TYI
C00020 00008 TYO
C00021 00009 FORCE OUTPUT
C00023 00010 (entry rcc subr)
C00025 00011 This routine gets fresh mail to initialize the reader
C00027 00012 initialize-short
C00028 00013 This routine does a jobread into the right spot.
C00029 00014 wait-ok
C00030 00015 (entry em:send-simple-message subr)
C00032 00016 (entry em:send-control-char subr)
C00034 00017 (entry em:initialize subr)
C00035 00018 send-ok
C00036 00019 Storage for Mail routines
C00038 ENDMK
C⊗;
;;; MacLisp portion of the E/MacLisp Interface.
;;;
;;; An SFA/MAIL based system for communicating with
;;; an unstructured, standard text editor.
(declare (mapex t)
(special -em:jobnum-)
(fixnum -em:jobnum-))
(defun em:negotiate ()
(print 'waiting-for-mail)
(em:wait-mail)
(print 'got-mail)
(cond ((eq (em:get-mail) 'initiate)
(print 'initiate-received)
(print 'sending-reply)
(em:send-simple-message 'ok -em:jobnum-)
t)))
(defun em:toplevel ()
(let ((em:sfa (sfa-create (function em:mail-sfa) 0 'mail-sfa)))
(print 'Starting-negotiation)
(do () ((em:negotiate)))
(print 'Negotiation-complete)
(do ((message-type (progn (em:wait-mail)(print 'got-mail)
(prog2 () (em:get-mail)(print 'read-mail)))
(progn (em:wait-mail)(print 'got-mail)
(prog2 () (em:get-mail)(print 'read-mail)))))
(())
(print 'got-a-message)
(print (list 'message-type= message-type))
(*catch 'em:toplevel
(caseq message-type
(sexps
(em:eval-file em:sfa))
(control-chars
(em:eval-control-file em:sfa)))))))
(defun em:eval-file (sfa)
(let ((eof (ncons ())))
(let ((form (read sfa eof))
ans)
(cond ((eq form eof) t)
(t (print form)
(setq ans (errset (eval form)))
(cond (ans (print (car ans) sfa)
(print 'sent-answer)
(sfa-call sfa 'force-output ()))
(t (print 'error sfa)
(sfa-call sfa 'force-print ()))))))))
(defun em:eval-control-file (sfa)
(print 'tyiing-control-chars)
(do ((char (tyi sfa -1)
(tyi sfa -1)))
((= char -1) t)
(print (list 'got-control-char char))
(caseq char
((#o302 #o342)
(break ↑B t))
((#o307 #o347)
(*throw 'em:toplevel t))
)))
(defun em:initiate-conversation (jobn)
(em:send-simple-message 'initiate jobn)
(let ((answer (em:wait-mail)))
(caseq answer
(ok t)
(t ()))))
(setq -sfa- ())
(defun init (n)
(setq -sfa- (sfa-create 'em:mail-sfa 0 'mail-sfa))
(em:send-simple-message 'initiate n)
(em:wait-mail) (em:get-mail))
(defun em:force-print (x sfa)
(print x sfa)
(print 'printed)
(sfa-call sfa 'force-output ())
(print 'forced)
(read sfa))
;;; From E to MacLisp
;;; Mail
;;; wd1: Job# sending message
;;; wd2: type of message
;;; 0,,1: SEXPs
;;; 0,,2 control (meta) chars to follow (E macro format)
;;; 0,,4: Ready for answer
;;; 0,,10: not ready for answer
;;; 0,,100: initiating a conversation
;;; 0,,200: interrupt. do <esc>i <char>
;;; 0,,400: close connection (suicide)
;;; 0,,1000: ok (did the jobread)
;;; 0,,2000: notok
;;; 1,,0: Continuation needed
;;; 2,,0: Short (fits in the next =30 words, ends with null byte
;;; or falls off)
;;; wd3: -number of words,,address of 1k buffer
;;;
;;; From MacLisp to E
;;; Mail
;;; wd1: Job#
;;; wd2: type of message
;;; 0,,1: Start of E commands
;;; 0,,2: Start of answer (PP text)
;;; 0,,4: Ready for answer?
;;; 0,,10: acknowledging a conversation initiation
;;; 0,,1000: ok (did the jobread)
;;; 0,,2000: notok
;;; 1,,0: Continuation needed
;;; 2,,0: Short
;;; wd3: -number of words,,address of 1k buffer
(lap em:get-mail subr)
(args em:get-mail (nil . 0))
(defsym alpha 2)
(defsym beta 3)
(defsym short-bit 2)
(defsym meta-mask 400)
(defsym kill-bit 400)
(defsym control-mask 200)
(defsym cont-bit 1)
(defsym sexp-bit 1)
(defsym control-bit 2)
(defsym ready-bit 4)
(defsym not-ready-bit 10)
(defsym initiate-bit 100)
(defsym interrupt-bit 200)
(defsym ok-bit 1000)
(defsym not-ok-bit 2000)
em:get-mail
(skipl 0 mailinp) ;-1 means mail in and not read
(mail 2 mailbox) ;SRCV
(jfcl)
(setzm 0 mailinp)
(movei b 'nil)
(movem b (special sail-mail-interrupt))
(move tt mailbox) ;get the jobnum
(skipg 0 jobnum)
(jrst 0 gm1)
(came tt jobnum) ;correct one?
(jrst 0 false)
(movem tt jobread)
gm1 (movem tt jobnum)
(movem tt jobn2)
(jsp t fxcons) ;number cons
(movem a (special -em:jobnum-)) ;save it
(move tt (+ mailbox 1)) ;type bits
(jrst 0 em:mailtype)
true (movei a 't)
(popj p)
false (movei a 'nil)
(popj p)
(entry em:mailtype subr)
(args em:mailtype (nil . 0))
em:mailtype
(movei b 'nil)
(movem b (special -em:control-chars-))
(move tt (+ mailbox 1));type bits
(movei a 'nil) ;short flag
(tlne tt short-bit)
(movei a 't)
(movem a (special -em:shortp-))
(movei a 'nil)
(tlne tt cont-bit) ;continuation expected?
(movei a 't)
(movem a (special -em:continuation-))
(trne tt sexp-bit)
(jrst 0 sexps) ;sexps
(trne tt control-bit)
(jrst 0 cntrl) ;control chars
(trne tt ready-bit)
(jrst 0 ready) ;ready
(trne tt not-ready-bit)
(jrst 0 nready) ;not ready
(trne tt initiate-bit)
(jrst 0 initiate) ;initiate conversation
(trne tt interrupt-bit)
(jrst 0 interrupt) ;some interrupt
(trne tt ok-bit) ;ok
(jrst 0 ok)
(trne tt kill-bit) ;kill
(jrst 0 kill)
(trne tt not-ok-bit) ;not-ok
(jrst 0 not-ok)
(pushj p send-ok)
(movei a 'unknown)
(popj p)
sexps
(skipe 0 inbytes)
(jrst 0 snot-finished)
sresume (move a (+ mailbox 2)) ;get number of bytes
(move tt (+ mailbox 1));type bits
(setzm 0 tyi-inited) ;tyi not inited
(hlrem a inbytes) ;store it
(setom 0 mailprocessed)
(tlne tt short-bit) ;short?
(jrst 0 tshort)
(pushj p transfer-buffer)
(movei a 'sexps)
(popj p)
tshort (pushj p transfer-short)
(movei a 'sexps)
(popj p)
cntrl
(movei b 't)
(movem b (special -em:control-chars-))
(skipe 0 inbytes)
(jrst 0 cnot-finished)
cresume (setzm 0 tyi-inited) ;tyi not inited
(move tt (+ mailbox 1));type bits
(move a (+ mailbox 2)) ;get number of bytes
(hlrem a inbytes) ;store it
(setom 0 mailprocessed)
(tlne tt short-bit) ;short?
(jrst 0 tcshort)
(pushj p transfer-buffer)
(movei a 'control-chars)
(popj p)
tcshort (pushj p transfer-short)
(movei a 'control-chars)
(popj p)
ready (movei a 'ready)
(setom 0 mailprocessed)
(popj p)
nready (movei a 'not-ready)
(setom 0 mailprocessed)
(popj p)
initiate(movei a 'initiate)
(setom 0 mailprocessed)
(popj p)
interrupt
(movei a 'interrupt)
(setzm 0 mailprocessed)
(popj p)
not-ok
(movei a 'not-ok)
(setom 0 mailprocessed)
(popj p)
ok
(movei a 1) (ttyuuo 1 a)
(movei a 'ok)
(setzm 0 mailprocessed)
(popj p)
kill (pushj p send-ok)
(call 1 12) ;kill self
(entry snot subr)
snot-finished
(movei a 77)(ttyuuo 1 a)
(setzm 0 mailprocessed)
(setzm 0 tyi-inited)
(movei a sresume)
(movem a resume-pc)
(movei a 'sexps)
(popj p)
(entry cnot subr)
cnot-finished
(movei a 77)(ttyuuo 1 a)
(setzm 0 mailprocessed)
(setzm 0 tyi-inited)
(movei a cresume)
(movem a resume-pc)
(movei a 'control-chars)
(popj p)
(entry em:wait-mail subr)
(args em:wait-mail (nil . 0))
em:wait-mail
(722←33 0 mailint) ;imskcl
(mail 1 mailbox) ;WRCV
(721←33 0 mailint) ;imskst
(setom 0 mailinp) ;mail now in
(movei a 't)
(popj p)
(entry em:mask-off subr)
(args em:mask-off (nil . 0))
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:mask-on subr)
(args em:mask-on (nil . 0))
(721←33 0 mailint) ;imskst
(movei a 't)
(popj p)
(entry em:mail-sfa subr)
(args em:mail-sfa (nil . 3))
(movei a 0 b) ;operation type ignore the object
(caie a 'which-operations)
(jrst 0 t1)
(movei a '(tyi tyo force-output untyi))
(popj p)
t1 (cain a 'tyi) ;tyi?
(jrst 0 em:mail-tyi)
(cain a 'tyo) ;tyo?
(jrst 0 em:mail-tyo)
(cain a 'force-output) ;force output?
(jrst 0 em:mail-force-output)
(cain a 'untyi) ;untyi?
(jrst 0 em:mail-untyi)
(movei a 'nil)
(popj p)
;;; TYI
(entry em:mail-tyi)
em:mail-tyi
(movem c eofchar)
(skipe a (special -em:control-chars-))
(jrst 0 read-control-chars)
(skipe 0 untyif)
(jrst 0 untyi2)
(skipe 0 tyi-inited) ;tyi inited?
(skipn 0 inbytes) ;and nothing left?
(pushj p mail-refresh)
tyi1 (aosle 0 inbytes)
(pushj p mail-refresh)
inmailok
(ildb tt inpoint) ;get byte
(skipe 0 tt) ;0 means end of file
(jrst 0 fix1) ;what a bum!
(pushj p mail-refresh)
(jrst 0 tyi1)
em:mail-untyi
(aos 0 untyif)
(move b untyipdl)
(push b c)
(movem b untyipdl)
(popj p)
untyi2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
reof
(move a eofchar)
(popj p)
;;; TYO
em:mail-tyo
(move a @ c)
(idpb a outpoint) ;put it there
(sosg 0 outbytes) ;ready to send?
(pushj p mail-sendit)
(movei a 't)
(popj p)
;;; FORCE OUTPUT
em:mail-force-output
mail-sendit
(movei a 40) ;space
(idpb a outpoint)
(sos 0 outbytes) ;extra byte
(movei a outmail) ;address of buffer
(movem a (+ mailbox 2))
(move a outbytes)
(movei a #o5000)
(sub a outbytes)
(caile a 145.) ;short enough
(jrst 0 long-message) ;nope
(hrlzi tt outmail)
(hrri tt (+ mailbox 3))
(blt tt (+ mailbox 30.)) ;move to the right place
(hrli tt short-bit)
(jrst 0 send-message)
long-message
(hrli tt 0)
send-message
(hrri tt sexp-bit)
(movem tt (+ mailbox 1))
(movns 0 a)
(hrlzm a (+ mailbox 2))
(movei a outmail)
(hrrm a (+ mailbox 2))
(move a thisjob)
(movem a mailbox)
(pushj p wait-for-clear)
(mail 0 jobnum) ;mail it
(jrst 0 false)
(move a outpointtem) ;setup output byte count
(movem a outpoint)
(movei a #o5001))
(movem a outbytes)
(pushj p wait-ok) ;wait for acknowledgment
(pushj p em:mailtype)
(came a 'ok)
(jrst 0 false)
(jrst 0 true)
(entry rcc subr)
read-control-chars
(skipe 0 tyi-inited) ;tyi inited?
(skipn 0 inbytes)
(pushj p mail-refresh)
(pushj p rgetchar)
(cain t alpha)
(movei tt control-mask) ;saw an α
(jrst 0 read-meta) ;now maybe a β?
(cain t beta) ;saw a β, so now the char
(iori t meta-mask)
read-char
(pushj p rgetchar)
(ior tt t)
(jrst 0 fix1)
read-meta
(pushj p rgetchar)
(cain t beta)
(iori t meta-mask)
(jrst 0 (+ read-char 1))
rgetchar(skipe 0 untyif)
(jrst 0 runty2)
(aosle 0 inbytes)
(pushj p mail-refresh)
(ildb t inpoint)
(skipe 0 t)
(cain t 40) ;space?
(jrst 0 rgetchar) ;foo, go around
(popj p)
rceof (move a eofchar)
(subi p (% 0 0 1 1))
(popj p)
runty2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
;;; This routine gets fresh mail to initialize the reader
mail-refresh
(skipn 0 resume-pc) ;ready for crock?
(jrst 0 mr3) ;nope
(skipn 0 mailprocessed) ;processed?
(jrst 0 mr1) ;get the next batch
mr3 (pushj p em:wait-mail) ;wait for response
(pushj p em:get-mail) ;get the mail
mr2 (move b (+ mailbox 2)) ;bytes delivered
(hlrem b inbytes)
(move b (special -em:shortp-))
(camn b 't) ;short
(pushj p 'initialize-short)
(movei c 'nil)
(cain a 'control-chars) ;control chars?
(movei c 'T)
(movem c control-chars)
(move a inpointtem) ;byte pointer template
(movem a inpoint)
(popj p)
mr1 (pushj p @ resume-pc) ;get the rest
(jrst 0 mr2) ;continue
initialize-short
(hrlzi a inmail)
(hrri a (+ mailbox 3))
(blt a (+ inmail 30.)) ;move the stuff
(popj p)
;;; This routine does a jobread into the right spot.
transfer-buffer
(setom 0 tyi-inited) ready to read
(movei tt jobread)
(move a (+ mailbox 2))
(movem a (+ jobread 1))
(calli tt 400050) ;jobrd
(jrst 0 false)
(jrst 0 send-ok)
(popj p) ;good return
wait-ok
(movei tt 55)(ttyuuo 1 tt)
(722←33 0 mailint) ;imskcl
(mail 1 mailbox) ;WRCV
(721←33 0 mailint) ;imskst
(move tt (+ mailbox 2))
(setzm 0 mailinp)
(trnn tt ok-bit)
(jrst 0 true)
(jrst 0 false)
(entry em:send-simple-message subr)
(args em:send-simple-message (nil . 2))
(cain a 'initiate)
(jrst 0 initiate-message)
(cain a 'ok)
(jrst 0 ok-message)
(cain a 'not-ok)
(jrst 0 not-ok-message)
(cain a 'ready)
(jrst 0 ready-message)
(cain a 'not-ready)
(jrst 0 not-ready-message)
(movei a 'Invalid-message)
(popj p)
initiate-message
(movei a initiate-bit)
(jrst 0 send-simple-message)
ok-message
(movei a 136)(ttyuuo 1 a)
(movei a ok-bit)
(jrst 0 send-simple-message)
not-ok-message
(movei a not-ok-bit)
(jrst 0 send-simple-message)
ready-message
(movei a ready-bit)
(jrst 0 send-simple-message)
not-ready-message
(movei a not-ready-bit)
send-simple-message
(movem a (+ mailb2 1))
(move b 0 b)
(movem b jobn2)
(movem b jobnum)
(move b thisjob)
(movem b mailb2)
(movem b mailbox)
(pushj p wait-for-clear)
(mail 0 jobn2)
(jrst 0 false)
(jrst 0 true)
wait-for-clear
(mail 4 jobnum)
(popj p)
(setz tt)
(calli tt 31)
(jrst 0 wait-for-clear)
(entry em:send-control-char subr)
(args em:send-control-char (nil . 2))
send-control-char
(movei t -1) ;count
(move tt outchartem)
(move a 0 a) ;get character
(trze a 200) ;control bit
(pushj p c1) ;push control
(trze a 400) ;meta bit
(pushj p m1) ;push meta
(idpb a tt)
(movei a control-bit)
(hrli a short-bit) ;short control chars
(movem a (+ mailb2 1))
(hrlzm t (+ mailb2 2))
(movei a outmail)
(hrrm a (+ mailb2 2))
(move b 0 b)
(movem b jobn2)
(movem b jobnum)
(move b thisjob)
(movem b mailb2)
(movem b mailbox)
(pushj p wait-for-clear)
(mail 0 jobn2)
(jrst 0 false)
(jrst 0 true)
c1 (movei r 2) ;alpha
(idpb r tt) ;send it
(sos 0 t) ;decrement
(popj p)
m1 (movei r 3) ;beta
(idpb r tt) ;send it
(sos 0 t) ;decrement
(popj p)
(entry em:initialize subr)
(args em:initialize (nil . 0))
(setzm 0 mailinp)
(setom 0 jobnum)
(calli tt 30)
(movem tt thisjob)
(jrst 0 fix1)
transfer-short
(hrlzi a (+ mailbox 3)) ;move from here
(hrri a inmail) ;to here
(blt a (+ inmail 30.)) ;transfer 30
(setom 0 tyi-inited) ;ready to read
(jrst 0 send-ok)
send-ok
(movei a 136)(ttyuuo 1 a)
(movei a ok-bit)
(movem a (+ mailb2 1))
(move b thisjob)
(movem b mailb2)
(pushj p wait-for-clear)
(mail 0 jobn2)
(jrst 0 false)
(jrst 0 true)
;;; Storage for Mail routines
mailinp (0) ;-1 means mail in and not read
mailint (4000000000)
jobnum (0)
(0 0 mailbox)
(entry mailbox subr)
mailbox (block 32.) ;mail
jobn2 (0)
(0 0 mailb2)
(entry mailb2 subr)
mailb2(block 32.) ;short mail
(entry inmail subr)
inmail (block 1000) ;text
(entry outmail subr)
outmail (block 1000) ;text
stack (block 20)
untyipdl (777760←22 0 stack)
untyif (0)
(entry inpoint subr)
inpoint (700←22 0 (- inmail 1))
inpointtem (700←22 0 (- inmail 1))
inbytes (0)
outpoint (700←22 0 (- outmail 1))
outpointtem (700←22 0 (- outmail 1))
outchartem (700←22 0 (+ mailb2 2))
outbytes (5001)
control-chars (0)
mailprocessed (-1) ;0 means not processed
tyi-inited (0) ;ready to read. 0 = nil, -1 = t
resume-pc (0) ;where to get more chars
eofchar (0) ;eof char
thisjob (0)
jobread (0)
(0)
(0 0 inmail)
()
(em:initialize)